﻿<%
'''XML操作类
Class XmlClass
	Private s_dom, s_doc, s_isOpen
	Private s_filePath, s_xsltPath
	
	'''构造
	Private Sub Class_Initialize()
		s_filePath = ""
		s_xsltPath = ""
		s_isOpen = False
		'Easp.Error(96) = "XML文件操作出错"
		'Easp.Error(97) = "对象不支持此属性或方法"
		'Easp.Error(98) = "未找到目标对象"
		'Easp.Error(99) = "保存XML文档出错"
	End Sub
	
	'''析构
	Private Sub Class_Terminate()
		If IsObject(s_doc) Then
			Set s_doc = Nothing
		End If
		If IsObject(s_dom) Then
			Set s_dom = Nothing
		End If
	End Sub
	
	'''获取节点对象的原始element对象
	Public Property Get Dom()
		If IsObject(s_dom) Then
			Set Dom = s_dom
		Else
			Set Dom = Nothing
		End If
	End Property
	
	'''获取当前对象的根节点对象
	Public Property Get Doc()
		If IsObject(s_doc) Then
			Set Doc = s_doc
		Else
			Set Doc = Nothing
		End If
	End Property
	
	'''查询是否已经打开存在的xml文件
	Public Property Get IsOpen()
		IsOpen = s_isOpen
	End Property
	
	'''选择器格式化
	'p_s:选择器规则
	Private Function transToXpath_(Byval p_s)
		p_s = RegReplace(p_s, "\p_s*,\p_s*", "|//")
		p_s = RegReplace(p_s, "\p_s*>\p_s*", "/")
		p_s = RegReplace(p_s, "\p_s+", "//")
		p_s = RegReplace(p_s, "(\[)([a-zA-Z]+\])", "$1@$2")
		p_s = RegReplace(p_s, "(\[)([a-zA-Z]+[!]?=[^\]]+\])", "$1@$2")
		p_s = RegReplace(p_s, "(?!\[\d)\]\[", " and ")
		p_s = Replace(p_s, "|", " | ")
		transToXpath_ = "//" & p_s
	End Function
	
	'''创建一个新的Dom
	Private Function newDom_()
		Dim t_o
		If IsInstall("MSXML2.DOMDocument") Then
			Set t_o = Server.CreateObject("MSXML2.DOMDocument")
		ElseIf IsInstall("Microsoft.XMLDOM") Then
			Set t_o = Server.CreateObject("Microsoft.XMLDOM")
		End If
		t_o.PreserveWhiteSpace = True
		t_o.Async = False
		t_o.SetProperty "SelectionLanguage", "XPath"
		Set newDom_ = t_o
		Set t_o = Nothing
	End Function
	
	'''用原始element对象建立Node对象
	'p_o:原始element对象
	Public Function NewNode(Byval p_o)
		Set NewNode = New XmlNodeClass
		NewNode.Dom = p_o
	End Function
	
	'''获取Server.MapPath
	'p_p:路径
	Private Function absPath_(Byval p_p)
		If IsN(p_p) Then
			absPath_ = "" : Exit Function
		End If
		If Mid(p_p,2,1)<>":" Then
			p_p = Server.MapPath(p_p)
		End If
		absPath_ = p_p
	End Function
	
	'''当前执行是否存在bug
	Private Function isErr_()
		Dim t_s
		isErr_ = False
		If s_dom.ParseError.Errorcode<>0 Then
			'With s_dom.ParseError
			'	t_s = t_s & "	<ul class=""dev"">" & vbCrLf
			'	t_s = t_s & "		<li class=""info"">以下信息针对开发者：</li>" & vbCrLf
			'	t_s = t_s & "		<li>错误代码：0x" & Hex(.Errorcode) & "</li>" & vbCrLf
			'	If Easp.Has(.Reason) Then t_s = t_s & "		<li>错误原因：" & .Reason & "</li>" & vbCrLf
			'	If Easp.Has(.Url) Then t_s = t_s & "		<li>错误来源：" & .Url & "</li>" & vbCrLf
			'	If Easp.Has(.Line) And .Line<>0 Then t_s = t_s & "		<li>错误行号：" & .Line & "</li>" & vbCrLf
			'	If Easp.Has(.Filepos) And .Filepos<>0 Then t_s = t_s & "		<li>错误位置：" & .Filepos & "</li>" & vbCrLf
			'	If Easp.Has(.SrcText) Then t_s = t_s & "		<li>源 文 本：" & .SrcText & "</li>" & vbCrLf
			'	t_s = t_s & "	</ul>" & vbCrLf
			'End With
			isErr_ = True
			'Easp.Error.Msg = t_s
			Errc.Raise(96)
		End If
	End Function
	
	'''打开本地服务器存在的xml文件,打开成功返回真(True)，打开失败返回假(False)
	'p_f:xml文件路径
	Public Function Open(Byval p_f)
		Open = False
		If IsN(p_f) Then
			Exit Function
		End If
		Set s_dom = newDom_()
		p_f = absPath_(p_f)
		s_dom.load(p_f)
		s_filePath = p_f
		If Not isErr_() Then
			Set s_doc = NewNode(s_dom.DocumentElement)
			Open = True
			s_isOpen = True
		Else
			Set s_dom = Nothing
		End If
	End Function

	'''从文本或者远程网址载入XML数据(如果是远程要use http)
	'p_s:XML文本或远程网址
	Public Sub [Load](Byval p_s)
		If IsN(p_s) Then
			Exit Sub
		End If
		Dim t_s
		If RegTest(p_s,"^([\w\d-]+>)?https?://") Then
			Dim t_h : Set t_h = New HttpClass
			t_s = t_h.Get(p_s)
			Set t_h = Nothing
		Else
			t_s = p_s
		End If
		Set s_dom = newDom_()
		s_dom.loadXML(t_s)
		If Not isErr_() Then
			Set s_doc = NewNode(s_dom.DocumentElement)
		Else
			Set s_dom = Nothing
		End If
	End Sub
	
	'''关闭当前xml
	Public Sub Close()
		Set s_doc = Nothing
		Set s_dom = Nothing
		s_filePath = ""
		s_isOpen = False
	End Sub
	
	'''保存已打开的修改后的ml文件
	Public Sub [Save]()
		If s_isOpen Then
			s_dom.Save(s_filePath)
		Else
			'Easp.Error.Msg = "（文档未处于打开状态）"
			Errc.Raise(99)
		End If
	End Sub
	
	'''把当前的XML数据保存为一个xml文件
	'p_p:保存路径
	Public Sub SaveAs(Byval p_p)
		Dim t_c,t_a,t_p
		If Instr(p_p,">")>0 Then
			t_c = CRight(p_p,">")
			p_p = CLeft(p_p,">")
		End If
		t_a = IfHas(t_c, "UTF-8")
		p_p = absPath_(p_p)
		Set t_p = s_dom.CreateProcessingInstruction("xml", "version=""1.0"" encoding=""" & t_a & """")
		If s_dom.FirstChild.BaseName<>"xml" Then
			s_dom.InsertBefore t_p, s_dom.FirstChild
		Else
			If Has(t_c) Then
				s_dom.ReplaceChild t_p, s_dom.FirstChild
			End If
		End If
		s_dom.Save(p_p)
		Set t_p = Nothing
	End Sub
	
	'''用XSLT将当前XML数据保存为XHTML文档
	'p_p:保存XHTML路径
	'p_x:XML数据或路径
	Public Sub SaveAsXHTML(Byval p_p, Byval p_x)
		Dim t_x,t_f : Set t_x = [New]
		If RegTest(p_x,"^([\w\d-]+>)?https?://") Then
			t_x.Load(p_x)
		Else
			t_x.Open(p_x)
		End If
		t_f = s_dom.TransformNode(t_x.s_dom)
		'FSO要进行独立
		Easp.Use "Fso"
		Easp.Fso.CreateFile p_p, t_f
		Set t_x = Nothing
	End Sub

	'''获取当前XML数据的根文档对象
	Public Property Get Root()
		Set Root = NewNode(s_dom)
	End Property
	
	'''创建新的XML对象
	Public Function [New]()
		Set [New] = New XmlClass
	End Function
	
	'''按规则选择Xml节点对象
	'p_t:规则字符串
	Public Default Function Find(Byval p_t)
		Dim t_o
		If RegTest(p_t,"^<[\s\S]+>$") Then
			Set t_o = s_dom.SelectNodes(transToXpath_(p_t))
		Else
			If RegTest(p_t, "[, >\[@:]") Then
				Set t_o = s_dom.SelectNodes(transToXpath_(p_t))
			Else
				Set t_o = s_dom.GetElementsByTagName(p_t)
			End If
		End If
		If t_o.Length = 0 Then
			'Easp.Error.Msg = "("&p_t&")"
			Errc.Raise(98)
		ElseIf t_o.Length = 1 Then
			Set Find = NewNode(t_o(0))
		Else
			Set Find = NewNode(t_o)
		End If
	End Function
	
	'''传回所有符合提供样式(pattern)的节点
	'p_p:包含XSL 样式的字符串
	Public Function [Select](Byval p_p)
		Set [Select] = NewNode(s_dom.SelectNodes(p_p))
	End Function
	
	'''传回第一个符合样式的节点
	'p_p:包含XSL 样式的字符串
	Public Function SelectOne(Byval p_p)
		Set SelectOne = NewNode(s_dom.SelectSingleNode(p_p))
	End Function
	
	'新建一个Node节点
	'p_n:[属性] 名称
	'p_v:对应值
	Public Function Create(Byval p_n, Byval p_v)
		Dim t_o,t_p,t_c
		If Instr(p_n," ")>0 Then
			t_c = LCase(CRight(p_n," "))
			p_n = CLeft(p_n," ")
		End If
		If t_c="comment" Then
			Set t_o = s_dom.CreateComment(p_v)
		Else
			Set t_o = s_dom.CreateElement(p_n)
			If t_c = "cdata" Then
				Set t_p = s_dom.CreateCDATASection(p_v)
			Else
				Set t_p = s_dom.CreateTextNode(p_v)
			End If
			t_o.AppendChild(t_p)
		End If
		Set Create = NewNode(t_o)
		Set t_o = Nothing
		Set t_p = Nothing
	End Function
End Class
'''XML的Node对象
Class XmlNodeClass
	'当前操作node
	Private s_node
	
	'''构造
	Private Sub Class_Initialize()
	End Sub
	
	'''析构
	Private Sub Class_Terminate()
		Set s_node = Nothing
	End Sub
	
	'''选择器格式化
	'p_s:选择器规则
	Private Function transToXpath_(Byval p_s)
		p_s = RegReplace(p_s, "\p_s*,\p_s*", "|//")
		p_s = RegReplace(p_s, "\p_s*>\p_s*", "/")
		p_s = RegReplace(p_s, "\p_s+", "//")
		p_s = RegReplace(p_s, "(\[)([a-zA-Z]+\])", "$1@$2")
		p_s = RegReplace(p_s, "(\[)([a-zA-Z]+[!]?=[^\]]+\])", "$1@$2")
		p_s = RegReplace(p_s, "(?!\[\d)\]\[", " and ")
		p_s = Replace(p_s, "|", " | ")
		transToXpath_ = "//" & p_s
	End Function
	
	'''设置当前节点对象的原始element对象
	'p_o:XML节点对象
	Public Property Let Dom(Byval p_o)
		If Not p_o Is Nothing Then
			Set s_node = p_o
		Else
			'Easp.Error.Msg = "(不是有效的XML对象)"
			Errc.Raise(97)
		End If
	End Property
	
	'''获取当前节点对象的原始element对象
	Public Property Get Dom()
		Set s_dom = s_node
	End Property
	
	'''创建新Node对象
	'p_o:XML节点对象
	Private Function new_(Byval p_o)
		Set new_ = New XmlNodeClass
		new_.Dom = p_o
	End Function

	'''查询当前Node对象是否是元素节点
	Public Property Get IsNode()
		IsNode = (TypeName(s_node) = "IXMLDOMElement")
	End Property
	
	'''查询当前Node对象是否是元素节点集合
	Public Property Get IsNodes()
		IsNodes = (TypeName(s_node) = "IXMLDOMSelection")
	End Property
	
	'''选择Node对象集合中的某一个Node对象
	'p_n:XML节点对象
	Public Default Property Get Item(Byval p_n)
		If IsNodes Then
			Set Item = new_(s_node(p_n))
		ElseIf IsNode And p_n = 0 Then
			Set Item = new_(s_node)
		Else
			'Easp.Error.Msg = "(不是有效的XML元素集合对象&lt;"&TypeName(s_node)&"&gt;)"
			Errc.Raise(97)
		End If
	End Property

	'''当前节点对象的子节点个数/如果当前是对象集则返回对象个数
	Public Property Get Length()
		If IsNode Then 
			Length = s_node.ChildNodes.Length
		Else
			Length = s_node.Length
		End If
	End Property
	
	'''删除当前Node元素节点的属性
	'p_s:属性名
	Public Function RemoveAttr(Byval p_s)
		If IsNode Then
			s_node.RemoveAttribute(p_s)
		ElseIf IsNodes Then
			Dim t_i
			For t_i = 0 To Length - 1
				s_node(t_i).RemoveAttribute(p_s)
			Next
		End If
		Set RemoveAttr = new_(s_node)
	End Function
	
	'''设置当前Node元素节点的属性
	'p_s:属性名
	'p_v:属性值
	Public Property Let Attr(Byval p_s, Byval p_v)
		If IsNull(p_v) Then
			RemoveAttr(p_s)
			Exit Property
		End If
		If IsNode Then
			s_node.SetAttribute p_s, p_v
		ElseIf IsNodes Then
			Dim t_i
			For t_i = 0 To Length - 1
				s_node(t_i).SetAttribute p_s, p_v
			Next
		End If
	End Property
	
	'''获取当前Node元素节点的属性
	'p_s:属性名
	Public Property Get Attr(Byval p_s)
		If Not IsNode Then
			Exit Property
		End If
		Attr = s_node.GetAttribute(p_s)
	End Property
	
	'''设置当前Node对象中元素节点的文本
	'p_v:文本字符串
	Public Property Let Text(Byval p_v)
		If IsNode Then
			If Has(p_v) Then
				s_node.Text = p_v
			End If
		ElseIf IsNodes Then
			Dim t_i
			For t_i = 0 To Length - 1
				If Has(p_v) Then
					s_node(t_i).Text = p_v
				End If
			Next
		End If
	End Property
	
	'''获取当前Node对象中元素节点的文本
	Public Property Get Text()
		If IsNode Then
			Text = s_node.Text
		ElseIf IsNodes Then
			Dim t_i
			For t_i = 0 To Length - 1
				Text = Text & s_node(t_i).Text
			Next
		End If
	End Property
	
	'''设置当前Node对象元素节点的值
	'p_v:值字符串
	Public Property Let Value(Byval p_v)
		If IsNode Then
			s_node.ChildNodes(0).NodeValue = p_v
		ElseIf IsNodes Then
			Dim t_i
			For t_i = 0 To Length - 1
				s_node(t_i).ChildNodes(0).NodeValue = p_v
			Next
		End If
	End Property
	
	'''获取当前Node对象元素节点的值
	Public Property Get Value()
		If Not IsNode Then
			Exit Property
		End If
		Value = s_node.ChildNodes(0).NodeValue
	End Property
	
	'''获取当前Node对象的Xml代码
	Public Property Get Xml()
		If IsNode Then
			Xml = s_node.Xml
		ElseIf IsNodes Then
			Dim t_i
			For t_i = 0 To Length - 1
				If t_i>0 Then
					Xml = Xml & vbCrLf
				End If
				Xml = Xml & s_node(t_i).Xml
			Next
		End If
	End Property
	
	'''传回适当命名空间名称的基本名称
	Public Property Get Name()
		If Not IsNode Then
			Exit Property
		End If
		Name = s_node.BaseName
	End Property
	
	'''返回节点形态
	Public Property Get [Type]()
		If IsNodes Then
			[Type] = 0
		Else
			[Type] = s_node.NodeType
		End If
	End Property
	
	'''返回节点形态描述
	Public Property Get TypeString()
	If IsNodes Then
			TypeString = "Selection"
		Else
			TypeString = s_node.NodeTypeString
		End If
	End Property

	'''获取当前XML数据的根文档对象
	Public Property Get Root()
		If Not IsNode Then
			Exit Property
		End If
		Set Root = new_(s_node.OwnerDocument)
	End property
	
	'''获取当前Node元素的父节点对象
	Public Property Get Parent()
		If Not IsNode Then
			Exit Property
		End If
		Set Parent = new_(s_node.ParentNode)
	End property
	
	'''获取当前Node元素的相应子节点
	'p_n:要获取的子节点下标
	Public Property Get Child(Byval p_n)
		If Not IsNode Then
			Exit Property
		End If
		Set Child = new_(s_node.ChildNodes(p_n))
	End property
	
	'''获取当前Node元素的上一同级元素
	Public Property Get Prev()
		If Not IsNode Then
			Exit Property
		End If
		Dim t_o : Set t_o = s_node.PreviousSibling
		Do While True
			If TypeName(t_o) = "Nothing" Or TypeName(t_o) = "IXMLDOMElement" Then
				Exit Do
			End If
			Set t_o = t_o.PreviousSibling
		Loop
		If TypeName(t_o) = "IXMLDOMElement" Then
			Set Prev = new_(t_o)
			Set t_o = Nothing
		Else
			'Easp.Error.Msg = "(没有上一同级元素)"
			Errc.Raise(96)
		End If
	End property
	
	'''获取当前Node元素的下一同级元素
	Public Property Get [Next]()
		If Not IsNode Then
			Exit Property
		End If
		Dim t_o : Set t_o = s_node.NextSibling
		Do While True
			If TypeName(t_o) = "Nothing" Or TypeName(t_o) = "IXMLDOMElement" Then
				Exit Do
			End If
			Set t_o = t_o.NextSibling
		Loop
		If TypeName(t_o) = "IXMLDOMElement" Then
			Set [Next] = new_(t_o)
			Set t_o = Nothing
		Else
			'Easp.Error.Msg = "(没有下一同级元素)"
			Errc.Raise(96)
		End If
	End property
	
	'''获取当前Node元素的第一个子节点
	Public Property Get First()
		If Not IsNode Then
			Exit Property
		End If
		Set First = new_(s_node.FirstChild)
	End Property
	
	'''获取当前Node元素的最后一个子节点
	Public Property Get Last()
		If Not IsNode Then
			Exit Property
		End If
		Set Last = new_(s_node.LastChild)
	End Property
	
	'''判断当前node元素是否有某一属性
	'p_s:属性名
	Public Function HasAttr(Byval p_s)
		If Not IsNode Then
			Exit Function
		End If
		Dim t_t : Set t_t = s_node.Attributes.GetNamedItem(p_s)
		HasAttr = (Not t_t Is Nothing)
		Set t_t = Nothing
	End Function
	
	'''判断当前node元素是否有子节点
	Public Function HasChild()
		If Not IsNode Then Exit Function
		HasChild = s_node.HasChildNodes()
	End Function
	
	'''按规则选择Xml节点对象
	'p_t:规则字符串
	Public Function Find(Byval p_t)
		If Not IsNode Then
			Exit Function
		End If
		Dim t_o
		If RegTest(p_t, "[, >\[@:]") Then
			Set t_o = s_node.SelectNodes(transToXpath_(p_t))
		Else
			Set t_o = s_node.GetElementsByTagName(p_t)
		End If
		If t_o.Length = 0 Then
			'Easp.Error.Msg = "("&p_t&")"
			Errc.Raise(98)
		ElseIf t_o.Length = 1 Then
			Set Find = new_(t_o(0))
		Else
			Set Find = new_(t_o)
		End If
	End Function
	
	'''传回所有符合提供样式(pattern)的节点
	'p_p:包含XSL 样式的字符串
	Public Function [Select](Byval p_p)
		If Not IsNode Then
			Exit Function
		End If
		Set [Select] = new_(s_node.SelectNodes(p_p))
	End Function
	
	'''传回第一个符合样式的节点
	'p_p:包含XSL 样式的字符串
	Public Function SelectOne(Byval p_p)
		If Not IsNode Then
			Exit Function
		End If
		Set SelectOne = new_(s_node.SelectSingleNode(p_p))
	End Function
	
	'''建立当前节点的复制
	'p_b:是否同时复制子节点
	Public Function Clone(Byval p_b)
		If Not IsNode Then
			Exit Function
		End If
		If IsN(p_b) Then
			p_b = True
		End If
		Set Clone = new_(s_node.CloneNode(p_b))
	End Function
	
	'''获取实际的XML/Dom对象
	Private Function nodeDom_(Byval p_o)
		Select Case TypeName(p_o)
		Case "IXMLDOMElement"
			Set nodeDom_ = p_o
		Case "XmlNodeClass"
			Set nodeDom_ = p_o.Dom
		End Select
	End Function
	
	'''添加子节点
	'p_o:XmlNodeClass对象或原生DOM
	Public Function Append(Byval p_o)
		If Not IsNode Then
			Exit Function
		End If
		s_node.AppendChild(nodeDom_(p_o))
		Set Append = new_(s_node)
	End Function
	
	'''用新对象替换当前node对象
	'p_o:要替代当前对象的node对象
	Public Function ReplaceWith(Byval p_o)
		If IsNode Then
			Call s_node.ParentNode.ReplaceChild(nodeDom_(p_o), s_node)
		ElseIf IsNodes Then
			Dim t_i,t_n
			For t_i = 0 To Length - 1
				Set t_n = nodeDom_(p_o).CloneNode(True)
				Call s_node(t_i).ParentNode.ReplaceChild(t_n, s_node(t_i))
			Next
		End If
		Set ReplaceWith = new_(s_node)
	End Function
	
	'''在当前节点前插入同级节点
	'p_o:要插入的node对象
	Public Function Before(Byval p_o)
		If IsNode Then
			Call s_node.ParentNode.InsertBefore(nodeDom_(p_o), s_node)
		ElseIf IsNodes Then
			Dim t_i,t_n
			For t_i = 0 To Length - 1
				Set t_n = nodeDom_(p_o).CloneNode(True)
				Call s_node(t_i).ParentNode.InsertBefore(t_n, s_node(t_i))
			Next
		End If
		Set Before = new_(s_node)
	End Function
	
	'''在指定节点后插入同级节点
	'p_n:指定节点
	'p_o:要插入的节点
	Private Sub insertAfter_(Byval p_n, Byval p_o)
		Dim t_p : Set t_p = p_o.ParentNode
		If t_p.LastChild Is p_o Then
			t_p.AppendChild(p_n)
		Else
			Call t_p.InsertBefore(p_n, p_o.NextSibling)
		End If
	End Sub
	
	'''在当前节点后插入同级节点
	'p_o:要插入的node对象
	Public Function After(Byval p_o)
		If IsNode Then
			Call insertAfter_(nodeDom_(p_o), s_node)
		ElseIf IsNodes Then
			Dim t_i,t_n
			For t_i = 0 To Length - 1
				Set t_n = nodeDom_(p_o).CloneNode(True)
				Call insertAfter_(t_n, s_node(t_i))
			Next
		End If
		Set After = new_(s_node)
	End Function

	'''清空当前对象的文本
	Public Function [Empty]()
		If IsNode Then
			s_node.Text = ""
		ElseIf IsNodes Then
			Dim t_i
			For t_i = 0 To Length - 1
				s_node(t_i).Text = ""
			Next
		End If
		Set [Empty] = new_(s_node)
	End Function
	
	'''删除当前对象所有子节点,清空当前对象的文本
	Public Function Clear()
		If IsNode Then
			s_node.Text = ""
			s_node.RemoveChild(s_node.FirstChild)
		ElseIf IsNodes Then
			Dim t_i
			For t_i = 0 To Length - 1
				s_node(t_i).Text = ""
				s_node(t_i).RemoveChild(s_node(t_i).FirstChild)
			Next
		End If
		Set Clear = new_(s_node)
	End Function
	
	'''合并相邻的Text节点并删除空的Text节点
	Public Function Normalize()
		If IsNode Then
			s_node.Normalize()
		ElseIf IsNodes Then
			Dim t_i
			For t_i = 0 To Length - 1
				s_node(t_i).Normalize()
			Next
		End If
		Set Normalize = new_(s_node)
	End Function
	
	'''删除当前node对象
	Public Sub Remove()
		If IsNode Then
			s_node.ParentNode.RemoveChild(s_node)
		ElseIf IsNodes Then
			Dim t_i
			For t_i = 0 To Length - 1
				s_node(t_i).ParentNode.RemoveChild(s_node(t_i))
			Next
		End If
	End Sub
End Class
%>